-- Piotr Bober
-- Compiler Construction 2009/10
-- the parser

module Parser
   (run, program, funDef, statement, codeBlock, bexp, aexp, fact)
   where

import DataTypes
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as T
import Text.ParserCombinators.Parsec.Expr

----------------------------------------------------------------------------------------------------
-- language syntax:
--
-- statement ::=
--                if ( <bool> ) <code_block> else <code_block>
--                if ( <bool> ) <code_block>
--                while ( <bool> ) <code_block>
--                do <code_block> while ( <bool> )
--                <code_block>
--                print " <string> "
--                print <arith>
--                read <arith>
--                return <arith>
--                <variable> = <arith>
--                local <variable> = <arith>
--                skip
--
-- variable ::=
--                <string>
--
-- code_block ::=
--                { <statements> }
--
-- statements ::=
--                <statement>
--                <statement> ; <statements>
--
-- bool ::=
--                false
--                true
--                ! <bool>
--                <bool> <bool_op> <bool>
--                <arith> <rel_op> <arith>
--                ( <bool> )
--
-- arith ::=
--                <const>
--                <var>
--                <fcall>
--                - <arith>
--                <arith> <arith_op> <arith>
--                <bool> ? <arith> : <arith>
--                ( <arith> )
--
-- const ::=
--                <double>
--
-- fcall ::=
--                <identifier> ( <args> )
--
-- args ::=
--                ""
--                <aexp>
--                <aexp> , <args>
--
-- bool_op ::=
--                ||
--                &&
--
-- rel_op ::=
--                ==
--                !=
--                <
--                <=
--                >
--                >=
--
-- arith_op ::=
--                +
--                -
--                *
--                /
--
----------------------------------------------------------------------------------------------------
-------- L E X E R ---------------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
languageDef :: T.LanguageDef ()
languageDef = T.LanguageDef {
                           T.commentStart = "/*",
                           T.commentEnd = "*/",
                           T.commentLine = "//",
                           T.nestedComments = False,
                           T.identStart = letter,
                           T.identLetter = letter <|> digit,
                           T.opStart = oneOf "!|&=<>+*-/?:",
                           T.opLetter = oneOf "|&=",
                           T.reservedNames = ["if", "else", "while", "do", "skip", "local",
                                            "print", "read", "return", "false", "true"],
                           T.reservedOpNames = ["!", "||", "&&", "==", "!=", "<", "<=", ">", ">=",
                                             "+", "-", "*", "/", "?", ":", "="],
                           T.caseSensitive = True}

lexer :: T.TokenParser ()
lexer = T.makeTokenParser languageDef

----------------------------------------------------------------------------------------------------
-------- P A R S E R -------------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------

-- basic parsers - from the lexer
identifier :: Parser String
identifier = T.identifier lexer

reserved :: String -> Parser ()
reserved = T.reserved lexer

reservedOp :: String -> Parser ()
reservedOp = T.reservedOp lexer

semiSep1 :: Parser a -> Parser [a]
semiSep1 = T.semiSep1 lexer

commaSep :: Parser a -> Parser [a]
commaSep = T.commaSep lexer

parens :: Parser a -> Parser a
parens = T.parens lexer

braces :: Parser a -> Parser a
braces = T.braces lexer

stringLiteral :: Parser String
stringLiteral = T.stringLiteral lexer

naturalOrFloat :: Parser (Either Integer Double)
naturalOrFloat = T.naturalOrFloat lexer

-- expressions
aexpAtom :: Parser AExp
aexpAtom = choice [aexpConst,
                   try aexpFCall,
                   aexpVar]

aexpConst, aexpFCall, aexpCond, aexpVar :: Parser AExp

aexpConst = number >>= return . Const

number :: Parser Double
number =
   do
      x <- naturalOrFloat
      case x of
         Left a -> return $ fromIntegral a
         Right b -> return b

aexpFCall =
   do
      i  <- identifier
      as <- args
      return $ FCall i as

-- unused ---------------------------------------------------------
aexpCond = undefined
{-   do
      b <- bexp
      reservedOp "?"
      a1 <- aexp
      reservedOp ":"
      a2 <- aexp
      return $ Conditional b a1 a2
------------------------------------------------------------------}

aexpVar = identifier >>= return . Var

args :: Parser Args
args = parens $ commaSep aexp

opTableA :: [[Operator Char () AExp]]
opTableA = [ [prefixA "-"],
             [binaryA "*" AssocLeft, binaryA "/" AssocLeft],
             [binaryA "+" AssocLeft, binaryA "-" AssocLeft]
             ]
binaryA :: String -> Assoc -> Operator Char () AExp
binaryA name assoc = Infix (reservedOp name >> return (BinOp name)) assoc

prefixA :: String -> Operator Char () AExp
prefixA name       = Prefix (reservedOp name >> return (UnOp name))

aexp :: Parser AExp
aexp = buildExpressionParser opTableA aexpAtom
--
bexpAtom :: Parser BExp
bexpAtom = bexpFalse <|> bexpTrue <|> bexpRel

bexpFalse, bexpTrue, bexpRel :: Parser BExp

bexpFalse = reserved "false" >> return FALSE
bexpTrue  = reserved "true"  >> return TRUE

bexpRel =
   do
      a1 <- aexp
      op <- relOp
      a2 <- aexp
      return $ Rel op a1 a2

relOp :: Parser String
relOp = choice [reservedOp "<" >> return "<",
                reservedOp "<=" >> return "<=",
                reservedOp ">" >> return ">",
                reservedOp ">=" >> return ">=",
                reservedOp "==" >> return "==",
                reservedOp "!=" >> return "!="]

opTableB :: [[Operator Char () BExp]]
opTableB = [ [prefixB "!"],
             [binaryB "&&" AssocLeft],
             [binaryB "||" AssocLeft]
             ]

binaryB :: String -> Assoc -> Operator Char () BExp
binaryB name assoc = Infix (reservedOp name >> return (BoolBinOp name)) assoc

prefixB :: String -> Operator Char () BExp
prefixB name       = Prefix (reservedOp name >> return Neg)

bexp :: Parser BExp
bexp = buildExpressionParser opTableB bexpAtom

-- main parsers
ifStmt, ifStmt', whileDoStmt, doWhileStmt, printStrStmt, printStmt, readStmt, returnStmt, assignStmt, initStmt, skipStmt :: Parser Statement

ifStmt =
   do
      reserved "if"
      b <- parens bexp
      s1 <- codeBlock
      reserved "else"
      s2 <- codeBlock
      return $ If b s1 s2

ifStmt' =
   do
      reserved "if"
      b <- parens bexp
      s <- codeBlock
      return $ If' b s

whileDoStmt =
   do
      reserved "while"
      b <- parens bexp
      s <- codeBlock
      return $ While b s

doWhileStmt =
   do
      reserved "do"
      s <- codeBlock
      reserved "while"
      b <- parens bexp
      return $ Do b s

printStrStmt =
   do
      reserved "print"
      s <- stringLiteral
      return $ PrintStr s

printStmt =
   do
      reserved "print"
      a <- aexp
      return $ Print a

readStmt =
   do
      reserved "read"
      v <- identifier
      return $ Read v

returnStmt =
   do
      reserved "return"
      a <- aexp
      return $ Return a

assignStmt =
   do
      i <- identifier
      reservedOp "="
      a <- aexp
      return $ Assign i a

initStmt =
   do
      reserved "local"
      i <- identifier
      reservedOp "="
      a <- aexp
      return $ Init i a

skipStmt =
   do
      reserved "skip"
      return Skip

statement :: Parser Statement
statement = choice [ try ifStmt,
                     ifStmt',
                     whileDoStmt,
                     doWhileStmt,
                     try printStrStmt,
                     printStmt,
                     readStmt,
                     returnStmt,
                     assignStmt,
                     initStmt,
                     skipStmt]

codeBlock :: Parser CodeBlock
codeBlock = braces $ semiSep1 statement

funDef :: Parser FunDef
funDef =
   do
      i <- identifier
      vars <- parens $ many identifier
      cb <- codeBlock
      return $ FunDef i vars cb

program :: Parser Program
program = many funDef

----------------------------------------------------------------------------------------------------
-------- R U N N I N G -----------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
run :: Show a => Parser a -> String -> IO a
run p s =
   case parse p "" s of
      Left e -> do
         putStr "parse error at "
         print e
         return undefined
      Right x -> do
--                    print x
                    return x
----------------------------------------------------------------------------------------------------
-- testing
fact :: String
fact = unlines ["factorial ( n )",
                "{",
                "\tlocal result = 1;",
                "\twhile( n > 0 )",
                "\t{",
                "\t\tresult = result * n;",
                "\t\tn = n-1",
                "\t};",
                "\treturn result",
                "}",
                "",
                "main()",
                "{",
                "\tlocal a = 0;",
                "\tprint \"please type a number: \";",
                "",
                "\tread a;",
                "\tprint \"factorial is \";",
                "\tprint factorial(a)",
                "}",
                ""]

test :: IO Program
test = run program fact
----------------------------------------------------------------------------------------------------
